home *** CD-ROM | disk | FTP | other *** search
/ Enter 2004 January / enter-2004-01.iso / files / maxima-5.9.0.exe / {app} / share / maxima / 5.9.0 / src / numerical / slatec / daie.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  11.9 KB  |  202 lines

  1. ;;; Compiled by f2cl version 2.0 beta 2002-05-06
  2. ;;; 
  3. ;;; Options: ((:prune-labels nil) (:auto-save t) (:relaxed-array-decls t)
  4. ;;;           (:coerce-assigns :as-needed) (:array-type ':simple-array)
  5. ;;;           (:array-slicing nil) (:declare-common nil)
  6. ;;;           (:float-format double-float))
  7.  
  8. (in-package "SLATEC")
  9.  
  10.  
  11. (let ((naif 0)
  12.       (naig 0)
  13.       (naip1 0)
  14.       (naip2 0)
  15.       (x3sml 0.0)
  16.       (x32sml 0.0)
  17.       (xbig 0.0)
  18.       (aifcs (make-array 13 :element-type 'double-float))
  19.       (aigcs (make-array 13 :element-type 'double-float))
  20.       (aip1cs (make-array 57 :element-type 'double-float))
  21.       (aip2cs (make-array 37 :element-type 'double-float))
  22.       (first nil))
  23.   (declare (type f2cl-lib:logical first)
  24.            (type (simple-array double-float (37)) aip2cs)
  25.            (type (simple-array double-float (57)) aip1cs)
  26.            (type (simple-array double-float (13)) aigcs aifcs)
  27.            (type double-float xbig x32sml x3sml)
  28.            (type f2cl-lib:integer4 naip2 naip1 naig naif))
  29.   (f2cl-lib:fset (f2cl-lib:fref aifcs (1) ((1 13))) -0.03797135849667)
  30.   (f2cl-lib:fset (f2cl-lib:fref aifcs (2) ((1 13))) 0.05919188853726364)
  31.   (f2cl-lib:fset (f2cl-lib:fref aifcs (3) ((1 13))) 9.862928057727998e-4)
  32.   (f2cl-lib:fset (f2cl-lib:fref aifcs (4) ((1 13))) 6.848843819076567e-6)
  33.   (f2cl-lib:fset (f2cl-lib:fref aifcs (5) ((1 13))) 2.5942025962194715e-8)
  34.   (f2cl-lib:fset (f2cl-lib:fref aifcs (6) ((1 13))) 6.176612774081375e-11)
  35.   (f2cl-lib:fset (f2cl-lib:fref aifcs (7) ((1 13))) 1.0092454172466117e-13)
  36.   (f2cl-lib:fset (f2cl-lib:fref aifcs (8) ((1 13))) 1.2014792511179939e-16)
  37.   (f2cl-lib:fset (f2cl-lib:fref aifcs (9) ((1 13))) 1.0882945588716993e-19)
  38.   (f2cl-lib:fset (f2cl-lib:fref aifcs (10) ((1 13))) 7.751377219668488e-23)
  39.   (f2cl-lib:fset (f2cl-lib:fref aifcs (11) ((1 13))) 4.454811203717564e-26)
  40.   (f2cl-lib:fset (f2cl-lib:fref aifcs (12) ((1 13))) 2.1092845231692342e-29)
  41.   (f2cl-lib:fset (f2cl-lib:fref aifcs (13) ((1 13))) 8.370173591074134e-33)
  42.   (f2cl-lib:fset (f2cl-lib:fref aigcs (1) ((1 13))) 0.018152365581161272)
  43.   (f2cl-lib:fset (f2cl-lib:fref aigcs (2) ((1 13))) 0.021572563166010757)
  44.   (f2cl-lib:fset (f2cl-lib:fref aigcs (3) ((1 13))) 2.567835698748325e-4)
  45.   (f2cl-lib:fset (f2cl-lib:fref aigcs (4) ((1 13))) 1.4265214119792408e-6)
  46.   (f2cl-lib:fset (f2cl-lib:fref aigcs (5) ((1 13))) 4.572114920018043e-9)
  47.   (f2cl-lib:fset (f2cl-lib:fref aigcs (6) ((1 13))) 9.525170843564709e-12)
  48.   (f2cl-lib:fset (f2cl-lib:fref aigcs (7) ((1 13))) 1.39256346057714e-14)
  49.   (f2cl-lib:fset (f2cl-lib:fref aigcs (8) ((1 13))) 1.5070999142762379e-17)
  50.   (f2cl-lib:fset (f2cl-lib:fref aigcs (9) ((1 13))) 1.2559148312567775e-20)
  51.   (f2cl-lib:fset (f2cl-lib:fref aigcs (10) ((1 13))) 8.306307377082133e-24)
  52.   (f2cl-lib:fset (f2cl-lib:fref aigcs (11) ((1 13))) 4.4657538493718574e-27)
  53.   (f2cl-lib:fset (f2cl-lib:fref aigcs (12) ((1 13))) 1.9900855034518866e-30)
  54.   (f2cl-lib:fset (f2cl-lib:fref aigcs (13) ((1 13))) 7.470288525653334e-34)
  55.   (f2cl-lib:fset (f2cl-lib:fref aip1cs (1) ((1 57))) -0.021469518589105386)
  56.   (f2cl-lib:fset (f2cl-lib:fref aip1cs (2) ((1 57))) -0.0075353825350433015)
  57.   (f2cl-lib:fset (f2cl-lib:fref aip1cs (3) ((1 57))) 5.971527949026381e-4)
  58.   (f2cl-lib:fset (f2cl-lib:fref aip1cs (4) ((1 57))) -7.283251254207612e-5)
  59.   (f2cl-lib:fset (f2cl-lib:fref aip1cs (5) ((1 57))) 1.1102971307392998e-5)
  60.   (f2cl-lib:fset (f2cl-lib:fref aip1cs (6) ((1 57))) -1.9503861522844057e-6)
  61.   (f2cl-lib:fset (f2cl-lib:fref aip1cs (7) ((1 57))) 3.786973885159515e-7)
  62.   (f2cl-lib:fset (f2cl-lib:fref aip1cs (8) ((1 57))) -7.929675297350979e-8)
  63.   (f2cl-lib:fset (f2cl-lib:fref aip1cs (9) ((1 57))) 1.7622476386742564e-8)
  64.   (f2cl-lib:fset (f2cl-lib:fref aip1cs (10) ((1 57))) -4.1107675396671944e-9)
  65.   (f2cl-lib:fset (f2cl-lib:fref aip1cs (11) ((1 57))) 9.984770057857894e-10)
  66.   (f2cl-lib:fset (f2cl-lib:fref aip1cs (12) ((1 57))) -2.510093251387122e-10)
  67.   (f2cl-lib:fset (f2cl-lib:fref aip1cs (13) ((1 57))) 6.500501929860696e-11)
  68.   (f2cl-lib:fset (f2cl-lib:fref aip1cs (14) ((1 57))) -1.7278184053936166e-11)
  69.   (f2cl-lib:fset (f2cl-lib:fref aip1cs (15) ((1 57))) 4.699378842824513e-12)
  70.   (f2cl-lib:fset (f2cl-lib:fref aip1cs (16) ((1 57))) -1.3046756562977438e-12)
  71.   (f2cl-lib:fset (f2cl-lib:fref aip1cs (17) ((1 57))) 3.689698478462679e-13)
  72.   (f2cl-lib:fset (f2cl-lib:fref aip1cs (18) ((1 57))) -1.0610872066468062e-13)
  73.   (f2cl-lib:fset (f2cl-lib:fref aip1cs (19) ((1 57))) 3.0984143848781875e-14)
  74.   (f2cl-lib:fset (f2cl-lib:fref aip1cs (20) ((1 57))) -9.17490807982414e-15)
  75.   (f2cl-lib:fset (f2cl-lib:fref aip1cs (21) ((1 57))) 2.752049140347211e-15)
  76.   (f2cl-lib:fset (f2cl-lib:fref aip1cs (22) ((1 57))) -8.353750115922047e-16)
  77.   (f2cl-lib:fset (f2cl-lib:fref aip1cs (23) ((1 57))) 2.563931129357935e-16)
  78.   (f2cl-lib:fset (f2cl-lib:fref aip1cs (24) ((1 57))) -7.950633762598855e-17)
  79.   (f2cl-lib:fset (f2cl-lib:fref aip1cs (25) ((1 57))) 2.48928363460307e-17)
  80.   (f2cl-lib:fset (f2cl-lib:fref aip1cs (26) ((1 57))) -7.864326933928737e-18)
  81.   (f2cl-lib:fset (f2cl-lib:fref aip1cs (27) ((1 57))) 2.5056873114399764e-18)
  82.   (f2cl-lib:fset (f2cl-lib:fref aip1cs (28) ((1 57))) -8.047420364163911e-19)
  83.   (f2cl-lib:fset (f2cl-lib:fref aip1cs (29) ((1 57))) 2.604097118952054e-19)
  84.   (f2cl-lib:fset (f2cl-lib:fref aip1cs (30) ((1 57))) -8.486954164056414e-20)
  85.   (f2cl-lib:fset (f2cl-lib:fref aip1cs (31) ((1 57))) 2.7847068821423376e-20)
  86.   (f2cl-lib:fset (f2cl-lib:fref aip1cs (32) ((1 57))) -9.195858953498612e-21)
  87.   (f2cl-lib:fset (f2cl-lib:fref aip1cs (33) ((1 57))) 3.055304318374239e-21)
  88.   (f2cl-lib:fset (f2cl-lib:fref aip1cs (34) ((1 57))) -1.0210354554794779e-21)
  89.   (f2cl-lib:fset (f2cl-lib:fref aip1cs (35) ((1 57))) 3.431118190743757e-22)
  90.   (f2cl-lib:fset (f2cl-lib:fref aip1cs (36) ((1 57))) -1.1591293417977495e-22)
  91.   (f2cl-lib:fset (f2cl-lib:fref aip1cs (37) ((1 57))) 3.9357728442002554e-23)
  92.   (f2cl-lib:fset (f2cl-lib:fref aip1cs (38) ((1 57))) -1.3428809802967176e-23)
  93.   (f2cl-lib:fset (f2cl-lib:fref aip1cs (39) ((1 57))) 4.6032878835200025e-24)
  94.   (f2cl-lib:fset (f2cl-lib:fref aip1cs (40) ((1 57))) -1.5850439270040642e-24)
  95.   (f2cl-lib:fset (f2cl-lib:fref aip1cs (41) ((1 57))) 5.481275667729675e-25)
  96.   (f2cl-lib:fset (f2cl-lib:fref aip1cs (42) ((1 57))) -1.903349371855047e-25)
  97.   (f2cl-lib:fset (f2cl-lib:fref aip1cs (43) ((1 57))) 6.635682302374009e-26)
  98.   (f2cl-lib:fset (f2cl-lib:fref aip1cs (44) ((1 57))) -2.3223116500263147e-26)
  99.   (f2cl-lib:fset (f2cl-lib:fref aip1cs (45) ((1 57))) 8.157640113429182e-27)
  100.   (f2cl-lib:fset (f2cl-lib:fref aip1cs (46) ((1 57))) -2.875824240632901e-27)
  101.   (f2cl-lib:fset (f2cl-lib:fref aip1cs (47) ((1 57))) 1.0173294509429016e-27)
  102.   (f2cl-lib:fset (f2cl-lib:fref aip1cs (48) ((1 57))) -3.6108791087422165e-28)
  103.   (f2cl-lib:fset (f2cl-lib:fref aip1cs (49) ((1 57))) 1.2857885403639935e-28)
  104.   (f2cl-lib:fset (f2cl-lib:fref aip1cs (50) ((1 57))) -4.592901037378547e-29)
  105.   (f2cl-lib:fset (f2cl-lib:fref aip1cs (51) ((1 57))) 1.6455970338207138e-29)
  106.   (f2cl-lib:fset (f2cl-lib:fref aip1cs (52) ((1 57))) -5.913421299843502e-30)
  107.   (f2cl-lib:fset (f2cl-lib:fref aip1cs (53) ((1 57))) 2.1310570066049933e-30)
  108.   (f2cl-lib:fset (f2cl-lib:fref aip1cs (54) ((1 57))) -7.701158157787599e-31)
  109.   (f2cl-lib:fset (f2cl-lib:fref aip1cs (55) ((1 57))) 2.7905333079689304e-31)
  110.   (f2cl-lib:fset (f2cl-lib:fref aip1cs (56) ((1 57))) -1.0138077151112841e-31)
  111.   (f2cl-lib:fset (f2cl-lib:fref aip1cs (57) ((1 57))) 3.6925801587196244e-32)
  112.   (f2cl-lib:fset (f2cl-lib:fref aip2cs (1) ((1 37))) -0.0017431449692937551)
  113.   (f2cl-lib:fset (f2cl-lib:fref aip2cs (2) ((1 37))) -0.0016789385432554166)
  114.   (f2cl-lib:fset (f2cl-lib:fref aip2cs (3) ((1 37))) 3.5965340335216606e-5)
  115.   (f2cl-lib:fset (f2cl-lib:fref aip2cs (4) ((1 37))) -1.3808186027392283e-6)
  116.   (f2cl-lib:fset (f2cl-lib:fref aip2cs (5) ((1 37))) 7.411228077315053e-8)
  117.   (f2cl-lib:fset (f2cl-lib:fref aip2cs (6) ((1 37))) -5.00238203900133e-9)
  118.   (f2cl-lib:fset (f2cl-lib:fref aip2cs (7) ((1 37))) 4.0069391741718424e-10)
  119.   (f2cl-lib:fset (f2cl-lib:fref aip2cs (8) ((1 37))) -3.673312427959051e-11)
  120.   (f2cl-lib:fset (f2cl-lib:fref aip2cs (9) ((1 37))) 3.760344395923738e-12)
  121.   (f2cl-lib:fset (f2cl-lib:fref aip2cs (10) ((1 37))) -4.2232133271874756e-13)
  122.   (f2cl-lib:fset (f2cl-lib:fref aip2cs (11) ((1 37))) 5.135094540336572e-14)
  123.   (f2cl-lib:fset (f2cl-lib:fref aip2cs (12) ((1 37))) -6.690958503904776e-15)
  124.   (f2cl-lib:fset (f2cl-lib:fref aip2cs (13) ((1 37))) 9.266675456412906e-16)
  125.   (f2cl-lib:fset (f2cl-lib:fref aip2cs (14) ((1 37))) -1.355143824160706e-16)
  126.   (f2cl-lib:fset (f2cl-lib:fref aip2cs (15) ((1 37))) 2.0811549631283097e-17)
  127.   (f2cl-lib:fset (f2cl-lib:fref aip2cs (16) ((1 37))) -3.3411649915917685e-18)
  128.   (f2cl-lib:fset (f2cl-lib:fref aip2cs (17) ((1 37))) 5.585785845859244e-19)
  129.   (f2cl-lib:fset (f2cl-lib:fref aip2cs (18) ((1 37))) -9.692190401523653e-20)
  130.   (f2cl-lib:fset (f2cl-lib:fref aip2cs (19) ((1 37))) 1.740457001288932e-20)
  131.   (f2cl-lib:fset (f2cl-lib:fref aip2cs (20) ((1 37))) -3.226409797311304e-21)
  132.   (f2cl-lib:fset (f2cl-lib:fref aip2cs (21) ((1 37))) 6.160744711066252e-22)
  133.   (f2cl-lib:fset (f2cl-lib:fref aip2cs (22) ((1 37))) -1.2093634798249005e-22)
  134.   (f2cl-lib:fset (f2cl-lib:fref aip2cs (23) ((1 37))) 2.4363276331013814e-23)
  135.   (f2cl-lib:fset (f2cl-lib:fref aip2cs (24) ((1 37))) -5.029142214974575e-24)
  136.   (f2cl-lib:fset (f2cl-lib:fref aip2cs (25) ((1 37))) 1.0622417554363568e-24)
  137.   (f2cl-lib:fset (f2cl-lib:fref aip2cs (26) ((1 37))) -2.2928428489598918e-25)
  138.   (f2cl-lib:fset (f2cl-lib:fref aip2cs (27) ((1 37))) 5.051817339295037e-26)
  139.   (f2cl-lib:fset (f2cl-lib:fref aip2cs (28) ((1 37))) -1.1349812371441241e-26)
  140.   (f2cl-lib:fset (f2cl-lib:fref aip2cs (29) ((1 37))) 2.59765565985607e-27)
  141.   (f2cl-lib:fset (f2cl-lib:fref aip2cs (30) ((1 37))) -6.051246215429396e-28)
  142.   (f2cl-lib:fset (f2cl-lib:fref aip2cs (31) ((1 37))) 1.433597779667728e-28)
  143.   (f2cl-lib:fset (f2cl-lib:fref aip2cs (32) ((1 37))) -3.451477570609e-29)
  144.   (f2cl-lib:fset (f2cl-lib:fref aip2cs (33) ((1 37))) 8.438751902136467e-30)
  145.   (f2cl-lib:fset (f2cl-lib:fref aip2cs (34) ((1 37))) -2.0939614229818818e-30)
  146.   (f2cl-lib:fset (f2cl-lib:fref aip2cs (35) ((1 37))) 5.270088734789455e-31)
  147.   (f2cl-lib:fset (f2cl-lib:fref aip2cs (36) ((1 37))) -1.344574330145534e-31)
  148.   (f2cl-lib:fset (f2cl-lib:fref aip2cs (37) ((1 37))) 3.475709645266012e-32)
  149.   (setq first f2cl-lib:%true%)
  150.   (defun daie (x)
  151.     (declare (type double-float x))
  152.     (prog ((sqrtx 0.0) (theta 0.0) (xm 0.0) (z 0.0) (daie 0.0) (eta 0.0f0))
  153.       (declare (type single-float eta)
  154.                (type double-float daie z xm theta sqrtx))
  155.       (cond
  156.        (first (setf eta (* 0.1f0 (f2cl-lib:freal (f2cl-lib:d1mach 3))))
  157.               (setf naif (initds aifcs 13 eta))
  158.               (setf naig (initds aigcs 13 eta))
  159.               (setf naip1 (initds aip1cs 57 eta))
  160.               (setf naip2 (initds aip2cs 37 eta))
  161.               (setf x3sml (coerce (expt eta 0.3333f0) 'double-float))
  162.               (setf x32sml (* 1.3104 (expt x3sml 2)))
  163.               (setf xbig (expt (f2cl-lib:d1mach 2) 0.6666))))
  164.       (setf first f2cl-lib:%false%)
  165.       (if (>= x -1.0) (go label20))
  166.       (multiple-value-bind
  167.           (var-0 var-1 var-2)
  168.           (d9aimp x xm theta)
  169.         (declare (ignore var-0))
  170.         (setf xm var-1)
  171.         (setf theta var-2))
  172.       (setf daie (* xm (cos theta)))
  173.       (go end_label)
  174.      label20
  175.       (if (> x 1.0) (go label30))
  176.       (setf z 0.0)
  177.       (if (> (abs x) x3sml) (setf z (expt x 3)))
  178.       (setf daie
  179.               (+ 0.375
  180.                  (- (dcsevl z aifcs naif)
  181.                     (* x (+ 0.25 (dcsevl z aigcs naig))))))
  182.       (if (> x x32sml)
  183.           (setf daie (* daie (exp (/ (* 2.0 x (f2cl-lib:fsqrt x)) 3.0)))))
  184.       (go end_label)
  185.      label30
  186.       (if (> x 4.0) (go label40))
  187.       (setf sqrtx (f2cl-lib:fsqrt x))
  188.       (setf z (/ (- (/ 16.0 (* x sqrtx)) 9.0) 7.0))
  189.       (setf daie
  190.               (/ (+ 0.28125 (dcsevl z aip1cs naip1)) (f2cl-lib:fsqrt sqrtx)))
  191.       (go end_label)
  192.      label40
  193.       (setf sqrtx (f2cl-lib:fsqrt x))
  194.       (setf z -1.0)
  195.       (if (< x xbig) (setf z (- (/ 16.0 (* x sqrtx)) 1.0)))
  196.       (setf daie
  197.               (/ (+ 0.28125 (dcsevl z aip2cs naip2)) (f2cl-lib:fsqrt sqrtx)))
  198.       (go end_label)
  199.      end_label
  200.       (return (values daie nil)))))
  201.  
  202.